(define-module (grump files)
  #:use-module (grump values)
  #:use-module (ice-9 ftw)
  #:use-module (ice-9 match)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-9 gnu)
  #:export (expand-file-name
            expand-directory-name
            expand-home-directory
            file-name
            file-name<?
            file-name-absolute
            file-size
            file-size<?
            file-size>?
            file-modified
            file-modified<?
            file-modified>?
            fold-files
            find-files)
  #:replace ((grump:call-with-input-file  . call-with-input-file)
             (grump:call-with-output-file . call-with-output-file)
             (grump:with-input-from-file  . with-input-from-file)
             (grump:with-output-to-file   . with-output-to-file)
             (grump:chdir . chdir)))

(define* (expand-file-name file #:optional (absolute? #t))
  "Canonicalize FILE by expanding home directories, removing redundant
path elements, and resolving paths relative to the current working
directory.  Pass ABSOLUTE? `#f' to prevent resolution of relative
paths."
  (define (path-split path)
    (match path
      ("" '())
      (_ (string-split path file-name-separator?))))

  (define (path-join parts)
    (match parts
      (("") file-name-separator-string)
      (_ (string-join parts file-name-separator-string))))

  (define (normalize parts)
    (reverse (fold (lambda (head tail)
                     (let ((keep (cons head tail)))
                       (match keep
                         ((_) keep)
                         (("" . _) tail)
                         (("." . _) tail)
                         ((".." "") tail)
                         ((".." ".") (list head))
                         ((".." ".." . _) keep)
                         ((".." . _) (cdr tail))
                         (_ keep))))
                   '() parts)))

  (if (string-null? file)
      (if absolute? (getcwd) ".")
      (path-join (normalize (path-split (if absolute?
                                            (expand-current-directory file)
                                            (expand-home-directory file)))))))

(define* (expand-directory-name dir #:optional (absolute? #t))
  "Canonicalize DIR as with `expand-file-name', returning a string that
ends in a path separator.  Pass ABSOLUTE? `#f' to prevent resolution of
relative paths."
  (file-name-as-directory (expand-file-name dir absolute?)))

(define (expand-current-directory file)
  "Make FILE absolute by expanding home directories and resolving paths
relative to the current working directory."
  (if (string-null? file)
      (getcwd)
      (let ((file (expand-home-directory file)))
        (if (not (absolute-file-name? file))
            (string-append (file-name-as-directory (getcwd)) file)
            file))))

(define (expand-home-directory file)
  "Replace a leading \"~\" segment in FILE with the current user's home
directory, or a leading \"~foo\" segment with the home directory of the
user \"foo\".  If there is no such user, returns FILE as-is."
  (define (user-home user)
    (and=> (false-if-exception (getpw user)) passwd:dir))

  (define (current-user-home)
    (or (getenv "HOME") (user-home (getuid))))

  (if (string-prefix? "~" file)
      (let* ((sep (or (string-index file file-name-separator?)
                      (string-length file)))
             (user (substring file 1 sep))
             (home (if (string-null? user)
                       (current-user-home)
                       (user-home user))))
        (if home
            (string-append home (substring file 1))
            file))
      file))

(define (file-name-as-directory file)
  "Ensure FILE ends in a path separator.  If FILE is the empty string,
returns \"./\"."
  (if (string-null? file)
      (string-append "." file-name-separator-string)
      (let ((last (string-ref file (1- (string-length file)))))
        (if (not (file-name-separator? last))
            (string-append file file-name-separator-string)
            file))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define-record-type <file>
  (make-file name base-dir stat-info)
  file?
  (name      file-name)
  (base-dir  file-base-dir)
  (stat-info file-stat))

(define (display-file file port)
  (format port "#<~a ~s size: ~a>"
          (file-type file)
          (file-name file)
          (file-size file)))

(set-record-type-printer! <file> display-file)

(define (file-type file)
  "Return a symbol representing the type of FILE."
  (match (and=> (file-stat file) stat:type)
    ('regular 'file)
    (#f 'file)
    (type type)))

(define (file-name-absolute file)
  "Return the absolute path to FILE."
  (let ((name (file-name file)))
    (if (not (absolute-file-name? name))
        (string-append (file-base-dir file) name)
        name)))

(define (file-size file)
  "Return the size of FILE in bytes."
  (and=> (file-stat file) stat:size))

(define (file-modified file)
  "Return the modification time of FILE as a unix timestamp."
  (and=> (file-stat file) stat:mtime))

(define (make-comparator func less)
  (lambda (a b)
    (let ((b-val (func b)))
      (or (not b-val)
          (let ((a-val (func a)))
            (and a-val (less a-val b-val)))))))

(define file-name<?
  (make-comparator file-name string<?))

(define file-size<?
  (make-comparator file-size <))

(define file-size>?
  (make-comparator file-size >))

(define file-modified<?
  (make-comparator file-modified <))

(define file-modified>?
  (make-comparator file-modified >))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (interpret-file-arg file)
  (if (file? file)
      (file-name-absolute file)
      (expand-home-directory file)))

(define* (grump:call-with-input-file file proc #:rest args)
  "Open FILE for input, and call (PROC PORT) with the resulting port.
When PROC returns, the port is closed.  FILE can be a string or a file
object from `find-files'.  See `call-with-input-file' for a description
of the remaining ARGS."
  (apply call-with-input-file (interpret-file-arg file) proc args))

(define* (grump:call-with-output-file file proc #:rest args)
  "Open FILE for output, and call (PROC PORT) with the resulting port.
When PROC returns, the port is closed.  FILE can be a string or a file
object from `find-files'.  See `call-with-output-file' for a description
of the remaining ARGS."
  (apply call-with-output-file (interpret-file-arg file) proc args))

(define* (grump:with-input-from-file file thunk #:rest args)
  "Open FILE for input as `current-input-port', and call (THUNK).  When
THUNK returns, the port is closed and `current-input-port' is restored.
FILE can be a string or a file object from `find-files'.  See
`with-input-from-file' for a description of the remaining ARGS."
  (apply with-input-from-file (interpret-file-arg file) thunk args))

(define* (grump:with-output-to-file file thunk #:rest args)
  "Open FILE for output as `current-output-port', and call (THUNK).  When
THUNK returns, the port is closed and `current-output-port' is restored.
FILE can be a string or a file object from `find-files'.  See
`with-input-from-file' for a description of the remaining ARGS."
  (apply with-output-to-file (interpret-file-arg file) thunk args))

(define* (grump:chdir file #:rest args)
  "Change the current working directory to FILE.  FILE can be a string or
a file object from `find-files'.  The return value is unspecified."
  (apply chdir (interpret-file-arg file) args))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define* (fold-files proc init path #:key
                     (absolute? #f)
                     (directories? #f)
                     (ignore-scm-dirs? #t)
                     #:allow-other-keys)
  (define enter?
    (if ignore-scm-dirs?
        (lambda (name state result)
          (not (member (basename name) '(".git" ".svn" "CVS"))))
        (const #t)))

  (define (ignore name stat result) result)
  (define down (if directories? proc ignore))
  (define up ignore)
  (define skip ignore)

  (define (error name stat errno result)
    (format (current-error-port) "warning: ~a: ~a~%"
            name (strerror errno))
    result)

  (first-value
   (file-system-fold enter? proc down up skip error init
                     (expand-file-name path absolute?)
                     stat)))

(define* (find-files #:optional (path "") (pred (const #t)) #:key
                     (absolute? #f)
                     (directories? #f)
                     (ignore-scm-dirs? #t)
                     (sort-by file-name<?)
                     #:rest args)
  (define base-dir
    (if absolute? #f (file-name-as-directory (getcwd))))

  (define (make-proc pred)
    (cond ((string? pred)
           (make-proc (make-regexp pred)))
          ((regexp? pred)
           (make-proc (lambda (file)
                        (regexp-exec pred (file-name file)))))
          (else
           (lambda (name stat result)
             (let ((file (make-file name base-dir stat)))
               (if (pred file)
                   (cons file result)
                   result))))))

  (let ((files (apply fold-files (make-proc pred) '() path args)))
    (if sort-by (sort! files sort-by) files)))
